home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / PROLOG / HUMBOLT / HUMBOLTS / _files / _humboltsr / DATAB._c < prev    next >
Text File  |  1990-12-08  |  23KB  |  864 lines
  1. /***************************************************
  2. ****************************************************
  3. **                                                **
  4. **  HU-Prolog     Portable Interpreter System     **
  5. **                                                **
  6. **  Release 1.62   January  1990                  **
  7. **                                                **
  8. **  Authors:      C.Horn, M.Dziadzka, M.Horn      **
  9. **                                                **
  10. **  (C) 1989      Humboldt-University             **
  11. **                Department of Mathematics       **
  12. **                GDR 1086 Berlin, P.O.Box 1297   **
  13. **                                                **
  14. ****************************************************
  15. ***************************************************/
  16.  
  17. #include "systems.h"
  18. #include "types.h"
  19. #include "errors.h"
  20. #include "atoms.h"
  21. #include "maxvars.h"
  22. #include "files.h"
  23.  
  24. /* 
  25.  
  26. The clauses which constitute the Prolog program are stored in skeletal
  27. form, with each variable replaced either by an anonymous variable or by
  28. a skeletal reference containing an offset from the base of a frame on
  29. the local stack.  The body of a clause is represented by a collection
  30. of terms chained immediately together.
  31.  
  32. */
  33.  
  34. IMPORT void ARGERROR(),ERROR(),ABORT(),SYSTEMERROR();      /* from linebufffer.c */
  35. IMPORT ATOM copyatom(),GetAtom(),LOOKATOM();
  36. IMPORT TERM A0,A1,A2;            /* from evalpreds.c */
  37. IMPORT int BCT;         /* from execute.c */
  38. IMPORT ENV CHOICEPOINT;
  39. IMPORT ENV NEWENV();            /* from unify.c */
  40. IMPORT ENV BASEENV,ENVTOP;
  41. IMPORT void KILLSTACKS();
  42. IMPORT void freeterms();
  43. IMPORT TERM A0,A1,A2;           /* from evalpreds.c     */
  44. IMPORT void FileError();        /* from files.c         */
  45. IMPORT void CloseFile();        /* from files.c         */
  46. IMPORT boolean FERRORFLAG;      /* from files.c         */
  47. IMPORT boolean ECHOFLAG,HALTFLAG,WARNFLAG;       /* fom prolog.c */
  48. IMPORT boolean VERBOSE;
  49. IMPORT boolean aSYSMODE;
  50. IMPORT ENV E;
  51. IMPORT TERM READIN();           /* from readin.c        */
  52. IMPORT void ATOMCHAR(),STARTATOM();
  53. IMPORT boolean FileExist();
  54. IMPORT string NEWATOM;
  55. IMPORT void CHECKATOM();
  56. IMPORT TERM phy_name();
  57. IMPORT ATOM atom();
  58. IMPORT boolean isatom(),EXECUTE(),INTRES();
  59. IMPORT int INTVALUE();
  60. IMPORT void TESTATOM();
  61. IMPORT void DISPLAY();
  62. IMPORT file OpenFile();
  63. IMPORT ATOM LOOKUP();
  64. IMPORT boolean UNIFY();
  65. IMPORT void reclaim_heap();
  66. IMPORT PHASE MODE;
  67.  
  68. /*
  69. EXPORT  boolean DOCONSULT(boolean);
  70. EXPORT boolean DOENSURE();
  71. EXPORT void abolish(),DOABOLISH(),retractclauses();
  72. EXPORT boolean DOCLAUSE(),DORETRACT();
  73. EXPORT void destroycl(CL);
  74. EXPORT void InitDatabase();
  75. EXPORT CLAUSE ADDCLAUSE();
  76. EXPORT TERM SKELETON();
  77. EXPORT CLAUSE ANDG,OR1G,OR2G,IMPG;
  78. */
  79.  
  80. /*
  81.    Produce a skeleton for p and add it to the database.  The new clause
  82.    is added at the front of the clause chain if asserta is true,
  83.    otherwise at the end.
  84. */
  85.  
  86. GLOBAL CLAUSE ANDG,OR1G,OR2G,IMPG;
  87.  
  88. /*
  89. Produce a skeleton for a variable v. When the first occurrence of
  90. v is encountered, it is tentatively translated as an anonymous
  91. variable, and a pointer to this variable is stored in the
  92. 'varmap' entry. If a second occurrence is encountered, the
  93. anonymous variable is changed to a skeletal reference.
  94. */
  95.  
  96. GLOBAL int  VARCT,VARTOP;
  97.  
  98. IMPORT  TERM VAR_TAB[MAXVARS]; /* from read.c */
  99. LOCAL   TERM VAR_REF[MAXVARS];
  100.  
  101. GLOBAL TERM SKELETON (REGISTER ATOM A, register TERM Y)
  102. { register TERM X, Z;
  103.   REGISTER TERM S;
  104.   register int J,N;
  105.   N=arity(A);
  106.   if(N==0) return nil_term;
  107.   Z=S=heapterms(N);
  108.   X=Y;
  109.   for(;;)
  110.   { Y=X; deref(Y);
  111.     if((A=name(Y))==UNBOUNDT) 
  112.     {
  113.         for(J=0;J<VARCT;++J) if(VAR_TAB[J]==Y) goto skel_var;
  114.         for(J=MAXVARS-VARTOP;J<MAXVARS; ++J)
  115.             if(VAR_TAB[J]==Y)
  116.             {
  117.                 name(VAR_REF[J])=SKELT;
  118.                 offset(VAR_REF[J])=term_units(VARCT);
  119.                 VAR_TAB[J]=nil_term;
  120.                 J=VARCT++;if(VARCT+VARTOP >=MAXVARS) ABORT(NVARSE);
  121.                 VAR_TAB[J] =Y;
  122.             skel_var:
  123.                 name(Z)=SKELT; offset(Z)=term_units(J);
  124.                 goto skel_exit;
  125.             }
  126.         /* enter new variable */
  127.         J=MAXVARS - ++VARTOP;if(VARCT+VARTOP>=MAXVARS) ABORT(NVARSE);
  128.         VAR_TAB[J]=Y;VAR_REF[J]=Z;
  129.         name(Z)=UNBOUNDT; val(Z)=nil_term;
  130.     skel_exit:
  131.         if (--N==0) break;
  132.         next_br(X); next_br(Z); continue;
  133.     }
  134.     else if(A==INTT) 
  135.          { name(Z)=INTT; ival(Z)=ival(Y); 
  136.            if (--N==0) break;
  137.            next_br(X); next_br(Z); continue;
  138.          }
  139.     else { if (--N==0)
  140.            { name(Z)=copyatom(A); 
  141.              if((N=arity(A))>0) 
  142.              { Z=son(Z)=heapterms(N);
  143.                X=son(Y);
  144.                continue;
  145.              }
  146.              son(Z)=nil_term; break;
  147.            }
  148.            name(Z)=copyatom(A); 
  149.            son(Z)=SKELETON(name(Z),son(Y));
  150.            next_br(X); next_br(Z); continue;
  151.          }
  152.   }
  153.   return S;
  154. }
  155.  
  156. GLOBAL CLAUSE ADDCLAUSE (register TERM Q)
  157. { ATOM A; 
  158.   register TERM Z,ZZ;
  159.   REGISTER TERM HEAD,X;
  160.   register CLAUSE CL;
  161.  
  162.     /* deref(Q); */
  163.     A=name(Q);
  164.     VARTOP=VARCT=0;
  165.     if(A!=ARROW_2) 
  166.     { 
  167.         if((system(A) && !aSYSMODE) || class(A)!=NORMP) ARGERROR();
  168.         A=copyatom(A);
  169.         HEAD=SKELETON(A,son(Q));
  170.         CL=heapterms(4); 
  171.         name(body(CL))=nil_atom; son(body(CL))=nil_term;
  172.     }
  173.     else /* name(A)==ARROW_2 */
  174.     { int I;
  175.       HEAD=arg1(Q); A=copyatom(name(HEAD));
  176.       if((system(A) && !aSYSMODE) || class(A)!=NORMP) ARGERROR();
  177.       HEAD=SKELETON(A,son(HEAD)); 
  178.       Z=arg2(Q); 
  179.       I=5;/* number of terms in a simple clause */
  180.       /* copy clause body onto heap */ 
  181.       while(name(Z)==COMMA_2) { Z=arg2(Z); I++; }
  182.       if(I>=MAXARITY) ABORT(DEPTHE);
  183.       CL=heapterms(I);
  184.       ZZ=body(CL); Z=arg2(Q);
  185.      skel_1:
  186.         if(name(Z)==COMMA_2) X=arg1(Z); else X=Z;
  187.         if(name(X)==UNBOUNDT) 
  188.     {
  189.         register int J;
  190.         for(J=0;J<VARCT;++J) if(VAR_TAB[J]==X) goto skel_var;
  191.         for(J=MAXVARS-VARTOP;J < MAXVARS; ++J)
  192.             if(VAR_TAB[J]==X)
  193.             {
  194.                 name(VAR_REF[J])=SKELT;
  195.                 offset(VAR_REF[J])=term_units(VARCT);
  196.                 VAR_TAB[J]=nil_term;
  197.                 J=VARCT++;if(VARCT+VARTOP >=MAXVARS) ABORT(NVARSE);
  198.                 VAR_TAB[J] =X;
  199.             skel_var:
  200.                 name(ZZ)=SKELT; offset(ZZ)=term_units(J);
  201.                 goto skel_exit;
  202.             }
  203.         /* enter new variable */
  204.         J=MAXVARS - ++VARTOP;if(VARCT+VARTOP >=MAXVARS) ABORT(NVARSE);
  205.         VAR_TAB[J]=X;VAR_REF[J]=ZZ;
  206.         name(ZZ)=UNBOUNDT; val(ZZ)=nil_term;
  207.     skel_exit:;
  208.     }
  209.         else
  210.         {
  211.             name(ZZ)=copyatom(name(X));
  212.             son(ZZ)=SKELETON(name(ZZ),son(X));
  213.         }
  214.         next_br(ZZ);
  215.         if(name(Z)==COMMA_2)
  216.         {
  217.             Z=arg2(Z); goto skel_1;
  218.         }
  219.         name(ZZ)=nil_atom; son(ZZ)=nil_term;
  220.     }
  221.     /* A=copyatom(A);  siehe oben */
  222.     if(aSYSMODE) setsystem(A);
  223.     name(CL)=CLAUSET;name(br(CL))=INTT;
  224.     nextcl(CL)=nil_term; setnvars(CL,VARCT); 
  225.     name(head(CL))=A; son(head(CL))=HEAD;
  226.     return CL;
  227. }
  228.  
  229. /****************** I N I T I A L I S A T I O N ***********/
  230.  
  231.  
  232. LOCAL TERM CURRTERM;
  233. LOCAL int CURRMAX;
  234.  
  235. LOCAL CLAUSE initclause(register int N, register int VARS)
  236. { register CLAUSE CL;
  237.   CL=heapterms(N+2); name(CL)=CLAUSET; nextcl(CL)=nil_term;
  238.   name(br(CL))=INTT; setnvars(CL,VARS);
  239.   CURRTERM=br(br(CL)); CURRMAX=N; 
  240.   return CL;
  241. }
  242.  
  243. LOCAL void setarg(register ATOM A, register TERM S)
  244. { if(CURRMAX-- <=0) SYSTEMERROR("InitDatabase.1");
  245.   name(CURRTERM)=A; son(CURRTERM)=S; inc_term(CURRTERM);
  246. }
  247.  
  248. LOCAL void skelarg(register int N)
  249. { if(CURRMAX-- <=0) SYSTEMERROR("InitDatabase.2");
  250.   name(CURRTERM)=SKELT; offset(CURRTERM)=term_units(N); 
  251.   inc_term(CURRTERM);
  252. }
  253.  
  254. LOCAL void closeclause(void)
  255. { if(CURRMAX-- <=0) SYSTEMERROR("InitDatabase.3");
  256.   name(CURRTERM)=nil_atom; son(CURRTERM)=nil_term;
  257. }
  258.  
  259. LOCAL TERM vars(register int M, register int N)
  260. { register TERM T;
  261.   T=heapterms(2); name(T)=SKELT; offset(T)=term_units(M);
  262.   name(br(T))=SKELT; offset(br(T))=term_units(N);
  263.   return T;
  264. }
  265.  
  266. LOCAL TERM v(register int N)
  267. { register TERM T;
  268.   T=heapterms(1); name(T)=SKELT; offset(T)=term_units(N);
  269.   return T;
  270. }
  271.  
  272. LOCAL void arithclause(register ATOM A)
  273. { register TERM P;
  274.     clause(A)=initclause(6,4);
  275.     setarg(A,vars(0,1));
  276.     setarg(EVALUATE_2,vars(2,0));
  277.     setarg(EVALUATE_2,vars(3,1));
  278.     setarg(CUT_0,nil_term);
  279.     P=heapterms(1); name(P)=A; son(P)=vars(2,3);
  280.     setarg(ACOMP_1,P);
  281.     closeclause();
  282. }
  283.  
  284. GLOBAL void InitDatabase(void)
  285. { register TERM P; 
  286.   register CLAUSE C;
  287.  
  288.   /* 
  289.      (P,Q):-P,Q. 
  290.   */
  291.   clause(COMMA_2)=ANDG=initclause(4,2);
  292.     setarg(COMMA_2,vars(0,1));
  293.     skelarg((0));
  294.     skelarg((1));
  295.     closeclause();
  296.  
  297.   /* 
  298.      (P;_):-P. 
  299.      (_;Q):-Q. 
  300.   */
  301.   clause(SEMI_2)=OR1G=initclause(3,2);
  302.     setarg(SEMI_2,vars(0,1));
  303.     skelarg((0));
  304.     closeclause();
  305.   nextcl(OR1G)=OR2G=initclause(3,2);
  306.     setarg(SEMI_2,vars(0,1));
  307.     skelarg((1));
  308.     closeclause();
  309.  
  310.   /*
  311.      (P->Q):-P,!,Q.
  312.   */
  313.   clause(IMPL_2)=IMPG=initclause(5,2);
  314.     setarg(IMPL_2,vars(0,1));
  315.     skelarg((0));
  316.     setarg(CUT_0,nil_term);
  317.     skelarg((1));
  318.     closeclause();
  319.  
  320.   /*
  321.      repeat.
  322.      repeat:-repeat.
  323.   */
  324.   C=clause(REPEAT_0)=initclause(2,0);
  325.     setarg(REPEAT_0,nil_term);
  326.     closeclause();
  327.   nextcl(C)=C;
  328.  
  329.   /*
  330.      true.
  331.   */
  332.   clause(TRUE_0)=initclause(2,0);
  333.     setarg(TRUE_0,nil_term);
  334.     closeclause();
  335.  
  336.   /*
  337.      not X:-X,!,fail.
  338.      not _.
  339.   */
  340.   clause(NOT_1)=C=initclause(5,1);
  341.     setarg(NOT_1,v(0));
  342.     skelarg((0));
  343.     setarg(CUT_0,nil_term);
  344.     setarg(FAIL_0,nil_term);
  345.     closeclause();
  346.   nextcl(C)=initclause(2,1);
  347.     setarg(NOT_1,v(0));
  348.     closeclause();
  349.  
  350.   /*
  351.      \+ X:-X,!,fail.
  352.      \+ _.
  353.   */
  354.   clause(NOT1_1)=C=initclause(5,1);
  355.     setarg(NOT1_1,v(0));
  356.     skelarg((0));
  357.     setarg(CUT_0,nil_term);
  358.     setarg(FAIL_0,nil_term);
  359.     closeclause();
  360.   nextcl(C)=initclause(2,1);
  361.     setarg(NOT1_1,v(0));
  362.     closeclause();
  363.  
  364.   /*
  365.      X=X.
  366.   */
  367.   clause(ISEQ_2)=initclause(2,1);
  368.     setarg(ISEQ_2,vars(0,0));
  369.     closeclause();
  370.  
  371.   /* 
  372.      X\=X:-!,fail.
  373.      _\=_.
  374.   */
  375.   clause(ISNEQ_2)=C=initclause(4,1);
  376.     setarg(ISNEQ_2,vars(0,0));
  377.     setarg(CUT_0,nil_term);
  378.     setarg(FAIL_0,nil_term);
  379.     closeclause();
  380.   nextcl(C)=initclause(2,2);
  381.     setarg(ISNEQ_2,vars(0,1));
  382.     closeclause();
  383.  
  384.   /*
  385.      [X,Y|T]:-consult(X),[Y|T].
  386.      [X] :- consult(X).
  387.   */
  388.   P=heapterms(2);
  389.   name(P)=SKELT; offset(P)=term_units(0);
  390.   name(br(P))=CONS_2; son(br(P))=vars(1,2);
  391.   clause(CONS_2)=C=initclause(4,3);
  392.     setarg(CONS_2,P);
  393.     setarg(CONSULT_1,v(0));
  394.     setarg(CONS_2,vars(1,2));
  395.     closeclause();
  396.   P=heapterms(2);
  397.   name(P)=SKELT; offset(P)=term_units(0);
  398.   name(br(P))=NIL_0; son(br(P))=nil_term;
  399.   nextcl(C)=initclause(3,1);
  400.     setarg(CONS_2,P);
  401.     setarg(CONSULT_1,v(0));
  402.     closeclause();
  403.  
  404.   /*
  405.      call(X):-X.
  406.   */
  407.   clause(CALL_1)=initclause(3,1);
  408.     setarg(CALL_1,v(0));
  409.     skelarg((0));
  410.     closeclause();
  411.  
  412.   /*
  413.      D := `E :- !,$dass(D,X).
  414.      D := E :- $evaluate(X,E),!,$dass(D,X).
  415.   */
  416.   P=heapterms(2);
  417.   name(P)=SKELT; offset(P)=term_units(0);
  418.   name(br(P))=QUOTE_1; son(br(P))=v(1);
  419.   clause(ASSIGN_2)=C=initclause(4,2);
  420.     setarg(ASSIGN_2,P);
  421.     setarg(CUT_0,nil_term);
  422.     setarg(DASSIGN_2,vars(0,1));
  423.     closeclause();
  424.   nextcl(C)=initclause(5,3);
  425.     setarg(ASSIGN_2,vars(0,1));
  426.     setarg(EVALUATE_2,vars(2,1));
  427.     setarg(CUT_0,nil_term);
  428.     setarg(DASSIGN_2,vars(0,2));
  429.     closeclause();
  430.  
  431.   /*
  432.      A=:=B :- $evaluate(AR,A),$evaluate(BR,B),!,$acomp(AR=:=BR).
  433.      etc.
  434.   */
  435.   arithclause(EQ_2);
  436.   arithclause(NE_2);
  437.   arithclause(LT_2);
  438.   arithclause(GT_2);
  439.   arithclause(LE_2);
  440.   arithclause(GE_2);
  441.  
  442. }
  443.  
  444.  
  445. GLOBAL void DOASSERT(boolean pos)
  446. /* A1   databasereference       */
  447. {                          /* A2   position                */
  448.     REGISTER ATOM A;
  449.     register CLAUSE CL,C,CX;
  450.  
  451.     if(pos && name(A1)!=UNBOUNDT) ARGERROR();
  452.  
  453.     if((A=name(A0))==ARROW_2) A=name(arg1(A0)); 
  454.     if( (system(A) && !aSYSMODE) || class(A)!=NORMP) ERROR(SYSPROCE);
  455.     A=copyatom(A);
  456.     if(name(A2)==INTT && ival(A2)==0)
  457.       { 
  458.             CL=ADDCLAUSE(A0);
  459.             nextcl(CL)=clause(A);
  460.             clause(A)=CL;  
  461.       }
  462.     else
  463.     if(name(A2)==END_0)
  464.       { CL=ADDCLAUSE(A0);
  465.         if(non_nil_clause(C=clause(A)))
  466.           { while(non_nil_clause(CX=nextcl(C)))C=CX;
  467.             nextcl(C)=CL;  /* md: noetig ? */
  468.           }
  469.         else clause(A)=CL;
  470.         nextcl(CL)=nil_clause;
  471.       }
  472.     else if(name(A2)==DBREF_1)   
  473.       { CX= (CLAUSE)INTVALUE(son(A2));
  474.         TESTATOM(A,head(CX));
  475.         if(denied(CX)) ARGERROR();
  476.         nextcl(CL=ADDCLAUSE(A0))=nextcl(CX); nextcl(CX)=CL;
  477.       }  
  478.     else 
  479.       { int i;
  480.         i=INTVALUE(A2);
  481.         if(i < 0) ARGERROR();
  482.         if(i==0)
  483.           { 
  484.             CL=ADDCLAUSE(A0);
  485.             nextcl(CL)=clause(A);
  486.             clause(A)=CL;  
  487.           }
  488.         else
  489.           {
  490.             if((C=clause(A))==nil_clause)ABORT(ARGE);
  491.             while(--i>0) 
  492.               { C=nextcl(C); 
  493.                 if(C==nil_clause) ARGERROR(); 
  494.               }
  495.             CL=ADDCLAUSE(A0);
  496.             nextcl(CL)=nextcl(C); nextcl(C)=CL;
  497.           }
  498.       }
  499.  
  500.     if(pos) (void) UNI(A1,mkfunc(DBREF_1,mkint((int)CL)));
  501.     return;
  502. }
  503.  
  504. GLOBAL void DOASSA(void)
  505. /* A0 term */
  506. {   
  507.     register ATOM A;
  508.     CLAUSE CL;
  509.     if((A=name(A0))==ARROW_2) A=name(arg1(A0)); 
  510.     if( (system(A) && !aSYSMODE) || class(A)!=NORMP) ERROR(SYSPROCE);
  511.     A=copyatom(A);
  512.     CL=ADDCLAUSE(A0);
  513.     nextcl(CL)=clause(A);
  514.     clause(A)=CL;  
  515.     return;
  516. }
  517.  
  518.  
  519. #ifdef DYNMEM
  520. GLOBAL CLAUSE clausechain;   /* used for retract */
  521. #else
  522. GLOBAL CLAUSE clausechain = nil_term;   /* used for retract */
  523. #endif
  524.  
  525. GLOBAL void notecl(register CLAUSE CL)
  526. { nextcl(CL)=clausechain;clausechain=CL; deny(CL); }
  527.  
  528. GLOBAL void destroycl(register CLAUSE CL)
  529. { register TERM T,B;
  530.   register int I;
  531.   B=CL; name(B)=INTT; /* makes freeterms going the right way */
  532.   T=body(CL); I=3;
  533.   /* the field nvars/nextcl should be cleared to avoid
  534.      errors in recursively freeing nonexisting term structures */
  535.   for(;;)
  536.   { I++; 
  537.     if(name(T)==nil_atom) { freeterms(I,B); break; }
  538.     next_br(T);
  539.   }
  540. }
  541.  
  542. GLOBAL void retractclauses(void)
  543. { /* this function should be called from toplevel */
  544.     register CLAUSE CL ;
  545.     while(non_nil_clause(CL=clausechain)){
  546.         clausechain=nextcl(CL);
  547.         destroycl(CL);
  548.     }
  549.     reclaim_heap(false);
  550. }
  551.  
  552.  
  553. LOCAL TERM GenTerm(CLAUSE CL, ENV CE)
  554. {
  555.     TERM H,B;
  556.     register TERM T,CP,BCE;
  557.  
  558.     BCE=base(CE);
  559.     if(CL==nil_clause) ARGERROR();
  560.     if(name(body(CL))==nil_atom) 
  561.     { /* facts */
  562.       H=mkfreevar(); 
  563.       UNIFY(1,H,head(CL),BE,BCE,MAXDEPTH); 
  564.       return H;
  565.     }
  566.     CP=body(CL);
  567.     if(non_nil_atom(name(br(CP)))) 
  568.     { /* body contructed from several calls */
  569.         B=T=mkfunc(COMMA_2,mk2sons(UNBOUNDT,nil_term,UNBOUNDT,nil_term));
  570.         for(;;)
  571.         { UNIFY(1,son(T),CP,BE,BCE,MAXDEPTH);
  572.           next_br(CP);
  573.           if(name(br(CP))==nil_atom)
  574.           { T=br(son(T)); name(T)=UNBOUNDT;
  575.             UNIFY(1,T,CP,BE,BCE,MAXDEPTH);
  576.             break;
  577.           }
  578.           T=br(son(T)); 
  579.           name(T)=COMMA_2; 
  580.           son(T)=mk2sons(UNBOUNDT,nil_term,UNBOUNDT,nil_term);
  581.         }
  582.     }
  583.     else B=body(CL); /* body consisting of exactly one call */
  584.     /* compose term from head and body */
  585.     T=mkfunc(ARROW_2,mk2sons(UNBOUNDT,nil_term,UNBOUNDT,nil_term));
  586.     UNIFY(1,son(T),head(CL),BE,BCE,MAXDEPTH); 
  587.     UNIFY(1,br(son(T)),B,BE,BCE,MAXDEPTH);
  588.     return T;
  589. }
  590.  
  591. GLOBAL boolean testheap(register CLAUSE CL)
  592.     /* true, if CL is an active goal */
  593. { 
  594.     register ENV i;
  595.     register CLAUSE CP;
  596.     register TERM CALL;
  597.     ATOM A;
  598.     boolean result=false;
  599.  
  600.     for(i=BASEENV;i<ENVTOP;inc_env(i))
  601.         if( non_nil_env(CALL=call(i)) && (A=name(CALL))>=FUNCNAME)
  602.             if( class(A)==NORMP && (rule(i)==CL))
  603.             { /* active goal */
  604.                 result=true;
  605.                 if( WARNFLAG) ws("WARNING: retract active goal\n");
  606.                 CP=clause(A);
  607.                 if(CP==CL) { rule(i)=DUMMYCL ; continue; }
  608.                 while(non_nil_clause(CP)  && (nextcl(CP)!=CL))
  609.                   CP=nextcl(CP);
  610.                 rule(i)=CP; 
  611.             }
  612.             else if(A==CLAUSE_2 && rule(i)==CL)
  613.             {   /* clause/2 is a  backtrackable built in, thats why
  614.                 rule(i) is set to BCT with son(BCT)=nextclause */
  615.                 result=true;
  616.                 if(WARNFLAG) ws("WARNING: retract active clause\n");
  617.                 rule(i)=nextcl(CL);
  618.             }
  619.     return result;
  620. }
  621.  
  622. LOCAL void clearcl(register CLAUSE CL)
  623. { 
  624.     register ATOM A; 
  625.     register CLAUSE hcl;
  626.     boolean active;
  627.     active=testheap(CL);
  628.     A=name(head(CL)); hcl=clause(A);
  629.     if(hcl==CL) 
  630.         clause(A)=nextcl(CL); 
  631.     else 
  632.     { 
  633.         while(nextcl(hcl) !=CL) hcl=nextcl(hcl);
  634.         nextcl(hcl)=nextcl(CL);
  635.     }
  636.     if(active)notecl(CL);else destroycl(CL);
  637. }
  638.  
  639.  
  640.  
  641. GLOBAL boolean DORETRACT(boolean pos, boolean all)
  642. /* retract/1 a clause from database */
  643. { ENV OC,NE ;
  644.  CLAUSE CL,NCL;
  645.  ATOM A;
  646.  OC=CHOICEPOINT;
  647.  if(pos && all)
  648.      SYSTEMERROR("datab.c/DORETRACT");
  649.  if(pos && name(A1)!=UNBOUNDT)
  650.  {
  651.     TESTATOM(DBREF_1,A1);
  652.     CL=(CLAUSE)INTVALUE(son(A1));
  653.     if(denied(CL))ARGERROR();
  654.     NE=NEWENV(var_sizes(CL));CHOICEPOINT=NE;
  655.     if(UNI(A0,GenTerm(CL,NE)))
  656.     { CHOICEPOINT=OC; clearcl(CL); return true; }
  657.     return false;
  658.   }
  659.  if(!all && !BCT)BCT=1;
  660.  A=name(A0);
  661.  if(A==ARROW_2) A=name(arg1(A0));
  662.  if(system(A)) ARGERROR();
  663.  CL=clause(A);
  664.  /* now CL is the first clause to check */
  665.  OC=CHOICEPOINT;
  666.  while(non_nil_clause(CL))
  667.  { NE=NEWENV(var_sizes(CL)); CHOICEPOINT=NE;
  668.    NCL=nextcl(CL);
  669.    if( !all && UNI(A0,GenTerm(CL,NE))) 
  670.      { CHOICEPOINT=OC; 
  671.        clearcl(CL); 
  672.        if(pos)return INTRES(A1,(int)CL); 
  673.        return true;
  674.      }
  675.    else if(all && UNIFY(1,A0,head(CL),BE,base(NE),MAXDEPTH))
  676.     { 
  677.         CHOICEPOINT=OC; 
  678.         clearcl(CL); 
  679.     }
  680.    KILLSTACKS(NE);
  681.    CL=NCL;
  682.  }
  683.  return(all);
  684. }
  685.  
  686.  
  687. GLOBAL boolean DOCLAUSE(boolean third_arg)
  688. { CLAUSE CL=nil_clause;
  689.   TERM T;
  690.   ENV NE;
  691.   boolean u;
  692.   
  693.  if(third_arg && (name(A2)!=UNBOUNDT))
  694.  {
  695.     TESTATOM(DBREF_1,A2);
  696.     CL=(CLAUSE)INTVALUE(son(A2));
  697.     if(denied(CL))ARGERROR();
  698.     NE=NEWENV(var_sizes(CL));
  699.     T=GenTerm(CL,NE);
  700.     if(name(T)==ARROW_2)
  701.         return UNI(A0,son(T)) && UNI(A1,br(son(T)));
  702.     else
  703.         return UNI(A0,T) && UNI(A1,mkatom(TRUE_0));
  704.  }
  705.  
  706.  if(BCT) CL= (CLAUSE)(BCT);
  707.  else { ATOM A; A=name(A0);
  708.  if(A<FUNCNAME)ARGERROR();
  709.         if(system(A))return false;
  710.         CL=clause(A);
  711.       }
  712.  while(non_nil_clause(CL))
  713.  { NE=NEWENV(var_sizes(CL));
  714.    T=GenTerm(CL,NE);
  715.    if(name(T)==ARROW_2)
  716.       u=UNI(A0,son(T)) && UNI(A1,br(son(T)));
  717.    else
  718.       u=UNI(A0,T) && UNI(A1,mkatom(TRUE_0));
  719.    if(u){ 
  720.        BCT= (int)nextcl(CL);
  721.        if(third_arg)return UNI(A2,mkfunc(DBREF_1,mkint((int)CL)));
  722.        return true;
  723.        }   
  724.    CL=nextcl(CL);
  725.    KILLSTACKS(NE);
  726.  } 
  727.  return false;
  728. }
  729.  
  730. GLOBAL void  abolish(ATOM A)
  731. { register CLAUSE CL,CL1;
  732.   if(system(A))return;
  733.   CL=clause(A); clause(A)=nil_clause;
  734.   while(non_nil_clause(CL))
  735.     { CL1=CL;CL=nextcl(CL); 
  736.       if (testheap(CL1)) notecl(CL1); else destroycl(CL1); 
  737.     }
  738. }
  739.  
  740. GLOBAL void  DOABOLISH(int i)
  741. {
  742.     ATOM A;
  743.     if(i==2)
  744.     {   CHECKATOM(A0);
  745.         if(A=LOOKATOM(name(A0),-INTVALUE(A1))) abolish(A);
  746.         return; 
  747.     }
  748.     if(isatom(A0))
  749.     {
  750.         for(i=0;i<=MAXARITY;i++)
  751.           if(non_nil_atom(A=LOOKATOM(name(A0),-i))) abolish(A);
  752.         return ;
  753.     }
  754.     if(non_nil_atom(A=atom(A0))) abolish(A);
  755. }
  756.     
  757.  
  758. GLOBAL boolean DOCONSULT(boolean reconsult)
  759. {
  760.     TERM X;
  761.     ATOM A,FILEATOM;
  762.     ATOM LASTA=nil_atom;
  763.     CLAUSE LASTCL=nil_term;
  764.     ENV EP,OLDE;
  765.     TERM oldfilename;
  766.     CLAUSE CX,CL;
  767.     boolean res=true;
  768.  
  769.     EP=E;
  770.     if(name(A0)==MINUS_1){ A0=arg1(A0); reconsult=true;}
  771.     if(reconsult)
  772.       for(A=GetAtom(nil_atom);non_nil_atom(A);A=GetAtom(A)) setnotrc(A);
  773.     CHECKATOM(A0);
  774.     if((FILEATOM=name(A0))==USER_0) FILEATOM=STDIN_0;;
  775.     oldfilename=FNAME(inputfile);
  776.     if((inputfile=OpenFile(phy_name(FILEATOM),read_mode))<0)
  777.         { FileError(CANTOP);res=false;goto exit;}
  778.     FLOGNAME(inputfile)=copyatom(FILEATOM);
  779.  
  780.     while(! HALTFLAG)
  781.     {   
  782.         retractclauses();
  783.         CHOICEPOINT=OLDE=E=NEWENV(0); BE=base(E);
  784.         if(VERBOSE && MODE!=SYSM)
  785.             if(FILEATOM==STDIN_0) ws("user >"); 
  786.             else if(!ECHOFLAG) ws(".");
  787.         X=READIN();
  788.         A=name(X);
  789.         if(A==END_0) HALTFLAG=true;  
  790.         else if(A==QUESTION_1 || A==ARROW_1 )
  791.         { 
  792.             LASTA=nil_atom;
  793.             name(X)=CALL_1; 
  794.             if( ! EXECUTE(X,E) && WARNFLAG && A!=ARROW_1)
  795.                 ws("WARNING: goal failed during consult/reconsult");
  796.         }
  797.         else 
  798.         {  
  799.             if(A ==ARROW_2) A=name(arg1(X));
  800.             if((system(A) && !aSYSMODE) || class(A) !=NORMP)
  801.                 ABORT(SYSPROCE);
  802.             A=copyatom(A);
  803.             if(reconsult && !rc(A)) 
  804.               { setrc(A); abolish(A); }
  805.             /* inline code for assert */        
  806.             if(non_nil_clause(CX=clause(A)))
  807.             {
  808.                 if(non_nil_atom(A) && A==LASTA) CX=LASTCL;
  809.                 else
  810.                     while(non_nil_clause(CL=nextcl(CX)))CX=CL;
  811.                 nextcl(CX)=CL=ADDCLAUSE(X);
  812.                 if(WARNFLAG && LASTA !=A)
  813.                 {
  814.                     ws("WARNING: new clauses for ");
  815.                     wq(A);ws("/");wi(arity(A));
  816.                     ws("\n");
  817.                 }
  818.             }
  819.             else
  820.                 clause(A)=CL=ADDCLAUSE(X);
  821.             nextcl(CL)=nil_clause; 
  822.             LASTA=A;
  823.             LASTCL=CL;
  824.         }
  825.         KILLSTACKS(OLDE);
  826.     }
  827.   exit:
  828.     HALTFLAG=false;
  829.     CloseFile(inputfile);
  830.     inputfile=OpenFile(oldfilename,read_mode);
  831.     ISEOF(inputfile)=false;
  832.     E=EP; BE=base(E);
  833.     return res;
  834. }
  835.  
  836. GLOBAL boolean DOENSURE(void)
  837. {
  838.     ATOM A;
  839.     register int ARITY;
  840.     register string s;
  841.     if(!(isatom(A0) && isatom(A1))) ARGERROR();
  842.     if(name(A2) !=INTT) ARGERROR();
  843.     ARITY=ival(A2);
  844.     if(ARITY < 0 || ARITY > MAXARITY) ARGERROR();
  845.     A=LOOKUP(tempcopy(name(A1)),ARITY,false);
  846.     A=copyatom(A);
  847.     if(ensure(A)) return true;
  848.     STARTATOM();
  849.     s=tempcopy(name(A0));
  850.     while(*s)ATOMCHAR(*s++);
  851.     s=tempcopy(name(A1));
  852.     while(*s)ATOMCHAR(*s++);
  853.     ATOMCHAR('.');
  854.     s=itoa(ARITY);
  855.     while(*s)ATOMCHAR(*s++);
  856.     ATOMCHAR(0); /* terminate string */
  857.     if(!FileExist(NEWATOM)) return false;
  858.     setensure(A);
  859.     A0=mkatom(LOOKUP(NEWATOM,0,false));
  860.     DOCONSULT(false);
  861.     return true;
  862. }
  863.  
  864.